第 12 章 交互图形
plotly 是一个功能非常强大的绘制交互式图形的 R 包。它支持下载图片、添加水印、自定义背景图片、工具栏和注释44 等一系列细节的自定义控制。下面结合 JavaScript 库 plotly.js 一起介绍,帮助文档 ?config 没有太详细地介绍,所以我们看看 config() 函数中参数 ... 和 JavaScript 库 plot_config.js 中的功能函数是怎么对应的。图12.1 中图片下载按钮对应 toImageButtonOptions 参数, 看 toImageButtonOptions 源代码,可知,它接受任意数据类型,对应到 R 里面就是列表。 watermark 和 displaylogo 都是传递布尔值(TRUE/FALSE),具体根据 JavaScript 代码中的 valType (参数值类型)决定,其它参数类似。另一个函数 layout 和函数 config() 是类似的,怎么传递参数值是根据 JavaScript 代码来的。
toImageButtonOptions: {
valType: 'any',
dflt: {},
description: [
'Statically override options for toImage modebar button',
'allowed keys are format, filename, width, height, scale',
'see ../components/modebar/buttons.js'
].join(' ')
},
displaylogo: {
valType: 'boolean',
dflt: true,
description: [
'Determines whether or not the plotly logo is displayed',
'on the end of the mode bar.'
].join(' ')
},
watermark: {
valType: 'boolean',
dflt: false,
description: 'watermark the images with the company\'s logo'
},
library(plotly, warn.conflicts = FALSE)
plot_ly(diamonds,
x = ~clarity, y = ~price,
color = ~clarity, colors = "Set1", type = "box"
) %>%
config(
toImageButtonOptions = list(
format = "svg", width = 450, height = 300,
filename = paste("plot", Sys.Date(), sep = "_")
),
modeBarButtons = list(list("toImage")),
watermark = FALSE,
displaylogo = FALSE,
locale = "zh-CN",
staticPlot = TRUE,
showLink = FALSE,
modeBarButtonsToRemove = c(
"hoverClosestCartesian", "hoverCompareCartesian",
"zoom2d", "zoomIn2d", "zoomOut2d",
"autoScale2d", "resetScale2d", "pan2d",
"toggleSpikelines"
)
) %>%
layout(
template = "plotly_dark",
images = list(
source = "https://images.plot.ly/language-icons/api-home/r-logo.png",
xref = "paper",
yref = "paper",
x = 1.00,
y = 0.25,
sizex = 0.2,
sizey = 0.2,
opacity = 0.5
),
annotations = list(
text = "DRAFT", # 水印文本
textangle = -30, # 逆时针旋转 30 度
font = list(
size = 40, # 字号
color = "gray", # 颜色
family = "Times New Roman" # 字族
),
opacity = 0.2, # 透明度
xref = "paper",
yref = "paper",
x = 0.5,
y = 0.5,
showarrow = FALSE # 去掉箭头指示
)
)图 12.1: 自定义细节
| 参数 | 作用 |
|---|---|
| displayModeBar | 是否显示交互图形上的工具条,默认显示 TRUE45。 |
| modeBarButtons | 工具条上保留的工具,如下载 "toImage",缩放 "zoom2d"46。 |
| modeBarButtonsToRemove | 工具条上要移除的工具,如下载和缩放图片 c("toImage", "zoom2d")。 |
| toImageButtonOptions | 工具条上下载图片的选项设置,包括名称、类型、尺寸等。47 |
| displaylogo | 是否交显示互图形上 Plotly 的图标,默认显示 TRUE48。 |
| staticPlot | 是否将交互图形转为静态图形,默认 FALSE。 |
| locale | 本土化语言设置,比如 "zh-CN" 表示中文。 |
12.1 散点图
| 类型 | 名称 |
|---|---|
scattercarpet |
地毯图 |
scatterternary |
三元图 |
scatter3d |
三维散点图 |
scattergeo |
地图散点图 |
scattermapbox |
地图散点图 Mapbox |
scatter |
散点图 |
scattergl |
散点图 GL |
scatterpolar |
极坐标散点图 |
scatterpolargl |
极坐标散点图 GL |
plotly.js 提供很多图层用于绘制各类图形 https://github.com/plotly/plotly.js/tree/master/src/traces
# 折线图
plot_ly(Orange,
x = ~age, y = ~circumference, color = ~Tree,
type = "scatter", mode = "markers"
)图 12.2: 其它常见图形
12.2 条形图
日常使用最多的图形无外乎散点图、柱形图(分组、堆积、百分比堆积等)
# 简单条形图
library(data.table)
diamonds <- as.data.table(diamonds)
p11 <- diamonds[, .(cnt = .N), by = .(cut)] %>%
plot_ly(x = ~cut, y = ~cnt, type = "bar") %>%
add_text(
text = ~ scales::comma(cnt), y = ~cnt,
textposition = "top middle",
cliponaxis = FALSE, showlegend = FALSE
)
# 分组条形图
p12 <- plot_ly(diamonds,
x = ~cut, color = ~clarity,
colors = "Accent", type = "histogram"
)
# 堆积条形图
p13 <- plot_ly(diamonds,
x = ~cut, color = ~clarity,
colors = "Accent", type = "histogram"
) %>%
layout(barmode = "stack")
# 百分比堆积条形图
# p14 <- plot_ly(diamonds,
# x = ~cut, color = ~clarity,
# colors = "Accent", type = "histogram"
# ) %>%
# layout(barmode = "stack", barnorm = "percent") %>%
# config(displayModeBar = F)
# 推荐使用如下方式绘制堆积条形图
dat = diamonds[, .(cnt = length(carat)), by = .(clarity, cut)] %>%
.[, pct := round(100 * cnt / sum(cnt), 2), by = .(cut)]
p14 <- plot_ly(
data = dat, x = ~cut, y = ~pct, color = ~clarity,
colors = "Set3", type = "bar"
) %>%
layout(barmode = "stack")
htmltools::tagList(p11, p12, p13, p14)12.3 折线图
其它常见的图形还要折线图、直方图、箱线图和提琴图
# 折线图
plot_ly(Orange,
x = ~age, y = ~circumference, color = ~Tree,
type = "scatter", mode = "markers+lines"
)图 12.3: 折线图
12.4 双轴图
模拟一组数据
set.seed(2020)
dat <- data.frame(
dt = seq(from = as.Date("2020-01-01"), to = as.Date("2020-01-31"), by = "day"),
search_qv = sample(100000:1000000, size = 31, replace = T)
) %>%
transform(valid_click_qv = sapply(search_qv, rbinom, n = 1, prob = 0.5)) %>%
transform(qv_ctr = valid_click_qv / search_qv)hoverinfo = "text" 表示 tooltips 使用指定的 text 映射,而 visible = "legendonly" 表示图层默认隐藏不展示,只在图例里显示,有时候很多条线,默认只是展示几条而已。举例如下
plot_ly(data = dat) %>%
add_bars(
x = ~dt, y = ~search_qv, color = I("gray80"), name = "搜索 QV",
text = ~ paste0(
"日期:", dt, "<br>",
"点击 QV:", format(valid_click_qv, big.mark = ","), "<br>",
"搜索 QV:", format(search_qv, big.mark = ","), "<br>",
"QV_CTR:", scales::percent(qv_ctr, accuracy = 0.01), "<br>"
),
hoverinfo = "text"
) %>%
add_bars(
x = ~dt, y = ~valid_click_qv, color = I("gray60"), name = "点击 QV",
text = ~ paste0(
"日期:", dt, "<br>",
"点击 QV:", format(valid_click_qv, big.mark = ","), "<br>",
"搜索 QV:", format(search_qv, big.mark = ","), "<br>",
"QV_CTR:", scales::percent(qv_ctr, accuracy = 0.01), "<br>"
), visible = "legendonly",
hoverinfo = "text"
) %>%
add_lines(
x = ~dt, y = ~qv_ctr, name = "QV_CTR", yaxis = "y2", color = I("gray40"),
text = ~ paste("QV_CTR:", scales::percent(qv_ctr, accuracy = 0.01), "<br>"),
hoverinfo = "text",
line = list(shape = "spline", width = 3, dash = "line")
) %>%
layout(
title = "",
yaxis2 = list(
tickfont = list(color = "black"),
overlaying = "y",
side = "right",
title = "QV_CTR(%)",
# ticksuffix = "%", # 设置坐标轴单位
tickformat = '.1%', # 设置坐标轴刻度
showgrid = F, automargin = TRUE
),
xaxis = list(title = "日期", showgrid = F, showline = F),
yaxis = list(title = " ", showgrid = F, showline = F),
margin = list(r = 20, autoexpand = T),
legend = list(
x = 0, y = 1, orientation = "h",
title = list(text = " ")
)
)图 12.4: 双轴图
12.5 直方图
plot_ly(iris,
x = ~Sepal.Length, colors = "Greys",
color = ~Species, type = "histogram"
)图 12.5: 分组直方图
12.6 箱线图
# 箱线图
plot_ly(diamonds,
x = ~clarity, y = ~price, colors = "Greys",
color = ~clarity, type = "box"
)图 12.6: 箱线图
12.7 提琴图
plot_ly(sleep,
x = ~group, y = ~extra, split = ~group,
type = "violin",
box = list(visible = T),
meanline = list(visible = T)
)图 12.7: 提琴图
plotly 包含图层 27 种,见表 12.3
| A | B | C |
|---|---|---|
| add_annotations | add_histogram | add_polygons |
| add_area | add_histogram2d | add_ribbons |
| add_bars | add_histogram2dcontour | add_scattergeo |
| add_boxplot | add_image | add_segments |
| add_choropleth | add_lines | add_sf |
| add_contour | add_markers | add_surface |
| add_data | add_mesh | add_table |
| add_fun | add_paths | add_text |
| add_heatmap | add_pie | add_trace |
12.8 气泡图
简单图形 scatter,分布图几类,其中 scatter、heatmap、scatterpolar 支持 WebGL 绘图引擎
# https://plotly.com/r/bubble-charts/
dat <- diamonds[, .(
carat = mean(carat),
price = sum(price),
cnt = .N
), by = .(cut)]
plot_ly(
data = dat, colors = "Greys",
x = ~carat, y = ~price, color = ~cut, size = ~cnt,
type = "scatter", mode = "markers",
marker = list(
symbol = "circle", sizemode = "diameter",
line = list(width = 2, color = "#FFFFFF"), opacity = 0.4
),
text = ~ paste(
sep = " ", "重量:", round(carat, 2), "克拉",
"<br>价格:", round(price / 10^6, 2), "百万"
),
hoverinfo = 'text'
) %>%
add_annotations(
x = ~carat, y = ~price, text = ~cnt,
showarrow = F, font = list(family = "sans")
) %>%
layout(
xaxis = list(hoverformat = ".2f"),
yaxis = list(hoverformat = ".0f")
)图 12.8: 气泡图
12.9 曲线图
plot_ly(
x = c(1, 2.2, 3), y = c(5.3, 6, 7),
type = "scatter", color = I("gray40"),
mode = "markers+lines", line = list(shape = "spline")
) %>%
add_annotations(
x = 2, y = 6, size = I(100),
text = TeX("x_i \\sim N(\\mu, \\sigma)")
) %>%
layout(
xaxis = list(showgrid = F, title = TeX("\\mu")),
yaxis = list(showgrid = F, title = TeX("\\alpha"))
) %>%
config(mathjax = 'cdn')图 12.9: 平滑曲线图
12.12 地图 I
plot_mapbox() 使用 Mapbox 提供的地图服务,因此,需要注册一个账户,获取 MAPBOX_TOKEN
data("quakes")
plot_mapbox(
data = quakes, colors = "Greys",
lon = ~long, lat = ~lat,
color = ~mag, size = 2,
type = "scattermapbox",
mode = "markers",
marker = list(opacity = 0.5)
) %>%
layout(
title = "Fiji Earthquake",
mapbox = list(
zoom = 3,
center = list(
lat = ~ median(lat - 5),
lon = ~ median(long)
)
)
) %>%
config(
mapboxAccessToken = Sys.getenv("MAPBOX_TOKEN")
)图 12.10: 斐济地震数据
plotly::plot_ly(
data = quakes,
lon = ~long, lat = ~lat,
type = "scattergeo", mode = "markers",
text = ~ paste0(
"站点:", stations, "<br>",
"震级:", mag
),
marker = list(
color = ~mag,
size = 10, opacity = 0.8,
line = list(color = "white", width = 1)
)
) %>%
plotly::layout(geo = list(
showland = TRUE,
landcolor = plotly::toRGB("gray95"),
subunitcolor = plotly::toRGB("gray85"),
countrycolor = plotly::toRGB("gray85"),
countrywidth = 0.5,
subunitwidth = 0.5,
lonaxis = list(
showgrid = TRUE,
gridwidth = 0.5,
range = c(160, 190),
dtick = 5
),
lataxis = list(
showgrid = TRUE,
gridwidth = 0.5,
range = c(-40, -10),
dtick = 5
)
))图 12.11: 斐济地震带分布
dat <- data.frame(state.x77,
stats = rownames(state.x77),
stats_abbr = state.abb
)
plotly::plot_ly(
data = dat,
type = "choropleth",
locations = ~stats_abbr,
locationmode = "USA-states",
colorscale = "Viridis",
z = ~Income
) |>
plotly::layout(
geo = list(scope = "usa"),
title = "1974年美国各州的人均收入",
legend = list(title = "收入")
)图 12.12: 美国各州收入
12.13 拟合图
plot_ly(economics,
type = "scatter",
x = ~date,
y = ~uempmed,
name = "observed unemployment",
mode = "markers+lines",
marker = list(
color = "red"
),
line = list(
color = "red",
dash = "dashed"
)
) %>%
add_trace(
x = ~date,
y = ~fitted(loess(uempmed ~ as.numeric(date))),
name = "fitted unemployment",
mode = "markers+lines",
marker = list(
color = "orange"
),
line = list(
color = "orange"
)
) %>%
layout(
title = "失业时间",
xaxis = list(
title = "日期",
showgrid = F
),
yaxis = list(
title = "失业时间(周)"
),
legend = list(
x = 0, y = 1, orientation = "v",
title = list(text = "")
)
)图 12.13: 拟合曲线
12.14 轨迹图
rasterly 百万量级的散点图
library(rasterly)
plot_ly(quakes, x = ~long, y = ~lat) %>%
add_rasterly_heatmap()图 12.14: 散点图
quakes %>%
rasterly(mapping = aes(x = long, y = lat)) %>%
rasterly_points()
图 12.14: 散点图
library(plotly)
# 读取数据
# uber 轨迹数据来自 https://github.com/plotly/rasterly
ridesDf <- readRDS(file = 'data/uber.rds')
ridesDf %>%
rasterly(mapping = aes(x = Lat, y = Lon)) %>%
rasterly_points()
图 12.15: 轨迹数据
12.15 三维图 (plotly)
plot_ly(z = ~volcano) %>%
add_surface()图 12.16: 三维图形
图 12.16: 三维图形
# https://plot.ly/r/reference/#scatter3d
transform(mtcars, am = ifelse(am == 0, "Automatic", "Manual")) %>%
plot_ly(x = ~wt, y = ~hp, z = ~qsec,
color = ~am, colors = c("#BF382A", "#0C4B8E")) %>%
add_markers() %>%
layout(scene = list(
xaxis = list(title = "Weight"),
yaxis = list(title = "Gross horsepower"),
zaxis = list(title = "1/4 mile time")
))图 12.16: 三维图形
12.16 甘特图
项目管理必备,如图所示,本项目拆分成7个任务,一共使用3种项目资源
# https://plotly.com/r/gantt/
# 项目拆解为一系列任务,每个任务的开始时间,持续时间和资源类型
df <- data.frame(
task = paste("Task", 1:8),
start = as.Date(c(
"2016-01-01", "2016-02-20", "2016-01-01",
"2016-04-10", "2016-06-09", "2016-04-10",
"2016-09-07", "2016-11-26"
)),
duration = c(50, 25, 100, 60, 30, 150, 80, 10),
resource = c("A", "B", "C", "C", "C", "A", "B", "B")
) %>%
transform(end = start + duration) %>%
transform(y = 1:nrow(.))
plot_ly(data = df) %>%
add_segments(
x = ~start, xend = ~end,
y = ~y, yend = ~y,
color = ~resource,
mode = "lines",
colors = "Greys",
line = list(width = 20),
showlegend = F,
hoverinfo = "text",
text = ~ paste(
" 任务: ", task, "<br>",
"启动时间: ", start, "<br>",
"周期: ", duration, "天<br>",
"资源: ", resource
)
) %>%
layout(
xaxis = list(
showgrid = F,
title = list(text = "")
),
yaxis = list(
showgrid = F,
title = list(text = ""),
tickmode = "array",
tickvals = 1:nrow(df),
ticktext = unique(df$task),
domain = c(0, 0.9)
),
annotations = list(
list(
xref = "paper", yref = "paper",
x = 0.80, y = 0.1,
text = paste0(
"项目周期: ", sum(df$duration), " 天<br>",
"资源类型: ", length(unique(df$resource)), " 个<br>"
),
font = list(size = 12),
ax = 0, ay = 0,
align = "left"
),
list(
xref = "paper", yref = "paper",
x = 0.1, y = 1,
xanchor = "left",
text = "项目资源管理",
font = list(size = 20),
ax = 0, ay = 0,
align = "left",
showarrow = FALSE
)
)
)图 12.17: 甘特图
12.17 帕雷托图
帕雷托图 20/80 法则
# 数据来自 https://github.com/plotly/datasets
dat <- data.frame(
complaint = c(
"Small portions", "Overpriced",
"Wait time", "Food is tasteless", "No atmosphere", "Not clean",
"Too noisy", "Food is too salty", "Unfriendly staff", "Food not fresh"
),
count = c( 621L, 789L, 109L, 65L, 45L, 30L, 27L, 15L, 12L, 9L)
)
dat <- dat[order(-dat$count), ] %>%
transform(cumulative = round(100 * cumsum(count) / sum(count), digits = 2))
# complaint 按 count 降序排列
dat$complaint <- reorder(x = dat$complaint, X = dat$count, FUN = function(x) 1/(1 + x))
plot_ly(data = dat) %>%
add_bars(
x = ~complaint, y = ~count,
showlegend = F, color = I("gray60")
) %>%
add_lines(
x = ~complaint, y = ~cumulative, yaxis = "y2",
showlegend = F, color = I("gray40")
) %>%
layout(
yaxis2 = list(
tickfont = list(color = "black"),
overlaying = "y",
side = "right",
title = "累积百分比(%)",
showgrid = F
),
xaxis = list(title = "投诉类型", showgrid = F, showline = F),
yaxis = list(title = "数量", showgrid = F, showline = F)
)图 12.18: 帕雷托图
reorder() 对 complaint 按照降序还是升序由 FUN 函数的单调性决定,单调增对应升序,单调减对应降序
12.18 时间线
library(vistime)
pres <- data.frame(
Position = rep(c("President", "Vice"), each = 3),
Name = c("Washington", rep(c("Adams", "Jefferson"), 2), "Burr"),
start = c("1789-03-29", "1797-02-03", "1801-02-03"),
end = c("1797-02-03", "1801-02-03", "1809-02-03"),
color = c("#cbb69d", "#603913", "#c69c6e"),
fontcolor = c("black", "white", "black")
)
vistime(pres, col.event = "Position", col.group = "Name")图 12.19: 时间线图
12.19 漏斗图
dat <- data.frame(
category = c("访问", "下载", "潜客", "报价", "下单"),
value = c(39, 27.4, 20.6, 11, 2)
) %>%
transform(percent = value / cumsum(value))
plot_ly(data = dat) %>%
add_trace(
type = "funnel",
y = ~category,
x = ~value,
color = ~category,
colors = "Set2",
text = ~ paste0(value, "<br>", sprintf("%.2f%%", 100*percent)) ,
hoverinfo = "text",
showlegend = FALSE
) %>%
layout(yaxis = list(
categoryarray = ~category,
title = ""
))图 12.20: 漏斗图
plotly::plot_ly(data = dat) %>%
plotly::add_trace(
type = "funnel",
y = ~category,
x = ~value,
marker = list(color = RColorBrewer::brewer.pal(n = 5, name = "Set2")),
textposition = "auto",
textinfo = "value+percent previous",
hoverinfo = "none"
) %>%
plotly::layout(yaxis = list(categoryarray = ~category, title = ""))图 12.21: 漏斗图
12.20 雷达图
plot_ly(
type = "scatterpolar", mode = "markers", fill = "toself"
) %>%
add_trace(
r = c(39, 28, 8, 7, 28, 39), color = I("gray40"),
theta = c("数学", "物理", "化学", "英语", "生物", "数学"),
name = "学生 A"
) %>%
add_trace(
r = c(1.5, 10, 39, 31, 15, 1.5), color = I("gray80"),
theta = c("数学", "物理", "化学", "英语", "生物", "数学"),
name = "学生 B"
) %>%
layout(
polar = list(
radialaxis = list(
visible = T,
range = c(0, 50)
)
)
)图 12.22: 雷达图
12.21 瀑布图
盈亏图
library(plotly)
library(dplyr)
dat <- data.frame(
x = c(
"销售", "咨询", "净收入",
"购买", "其他费用", "税前利润"
),
y = c(60, 80, 10, -40, -20, 0),
measure = c(
"relative", "relative", "relative",
"relative", "relative", "total"
)
) %>%
mutate(text = case_when(
y > 0 ~ paste0("+", y),
y == 0 ~ "",
y < 0 ~ as.character(y)
)) %>%
mutate(x = factor(x, levels = c(
"销售", "咨询", "净收入",
"购买", "其他费用", "税前利润"
)))
n_rows <- nrow(dat)
dat[nrow(dat), "text"] <- "累计"
# measure 取值为 'relative'/'total'/'absolute'
plotly::plot_ly(dat,
x = ~x, y = ~y, measure = ~measure, type = "waterfall",
text = ~text, textposition = "outside",
name = "收支", hoverinfo = "final",
connector = list(line = list(color = "gray")),
increasing = list(marker = list(color = "#66C2A5")),
decreasing = list(marker = list(color = "#FC8D62")),
totals = list(marker = list(color = "#8DA0CB"))
) %>%
plotly::layout(
title = "2018 年收支状态",
xaxis = list(title = "业务"),
yaxis = list(title = "金额"),
showlegend = FALSE
)图 11.98: 瀑布图
12.22 树状图
plotly 绘制 treemap 和 sunburst 图比较复杂,接口不友好, plotme 正好弥补不足。
12.24 调色板
plot_ly(iris,
x = ~Petal.Length, y = ~Petal.Width,
mode = "markers", type = "scatter",
color = ~ Sepal.Length > 6, colors = c("#132B43", "#56B1F7")
)
plot_ly(iris,
x = ~Petal.Length, y = ~Petal.Width, color = ~ Sepal.Length > 6,
mode = "markers", type = "scatter"
)
plot_ly(iris,
x = ~Petal.Length, y = ~Petal.Width, color = ~ Sepal.Length > 6,
mode = "markers", type = "scatter", colors = "Set2"
)
plot_ly(iris,
x = ~Petal.Length, y = ~Petal.Width, color = ~ Sepal.Length > 6,
mode = "markers", type = "scatter", colors = "Set1"
)构造 20 个类别 超出 Set1 调色板的范围,会触发警告说 Set1 没有那么多色块,但还是返回足够多的色块,也可以使用 viridis、plasma、magma 或 inferno 调色板
dat <- data.frame(
dt = rep(seq(
from = as.Date("2021-01-01"),
to = as.Date("2021-01-31"), by = "day"
), each = 20),
bu = rep(LETTERS[1:20], 31),
qv = rbinom(n = 20 * 31, size = 10000, prob = runif(20 * 31))
)
# viridis
plot_ly(dat,
x = ~dt, y = ~qv, color = ~bu,
mode = "markers", type = "scatter", colors = "viridis"
)图 12.23: 调色板
12.25 导出静态图形
orca (Open-source Report Creator App) 软件针对 plotly.js 库渲染的图形具有很强的导出功能,安装 orca 后,plotly::orca() 函数可以将基于 htmlwidgets 的 plotly 图形对象导出为 PNG、PDF 和 SVG 等格式的高质量静态图片。
12.26 静态图形转交互图形
函数 ggplotly() 将 ggplot 对象转化为交互式 plotly 对象
gg <- ggplot(faithful, aes(x = eruptions, y = waiting)) +
stat_density_2d(aes(fill = ..level..), geom = "polygon") +
xlim(1, 6) +
ylim(40, 100)静态图形
gg
转化为 plotly 对象
ggplotly(gg)添加动态点的注释,比如点横纵坐标、坐标文本,整个注释标签的样式(如背景色)
12.27 地图 II
leaflet 包制作地图,斐济是太平洋上的一个岛国,处于板块交界处,经常发生地震,如下图所示,展示 1964 年来 1000 次震级大于 4 级的地震活动。
library(leaflet)
data(quakes)
# Pop 提示
quakes$popup_text <- lapply(paste(
"编号:", "<strong>", quakes$stations, "</strong>", "<br>",
"震深:", quakes$depth, "<br>",
"震级:", quakes$mag
), htmltools::HTML)
# 构造调色板
pal <- colorBin("Spectral", bins = pretty(quakes$mag), reverse = TRUE)
p <- leaflet(quakes) |>
addProviderTiles(providers$CartoDB.Positron) |>
addCircles(lng = ~long, lat = ~lat, color = ~ pal(mag), label = ~popup_text) |>
addLegend("bottomright",
pal = pal, values = ~mag,
title = "地震震级"
) |>
addScaleBar(position = c("bottomleft"))
p
图 12.24: 斐济地震带
将上面的绘图部分保存为独立的 HTML 网页文件
library(htmlwidgets)
# p 就是绘图部分的数据对象
saveWidget(p, "fiji-map.html", selfcontained = T)
library(leaflet)
library(leaflet.extras)
quakes |>
leaflet() |>
addTiles() |>
addProviderTiles(providers$OpenStreetMap.DE) |>
addHeatmap(
lng = ~long, lat = ~lat, intensity = ~mag,
max = 100, radius = 20, blur = 10
)
图 12.25: 斐济地震带热力图
leafletCN 提供汉化
# 地图默认放大倍数
zoom <- 4
# 地图可以放大的倍数区间
minZoom <- 1
maxZoom <- 18
library(leaflet)
library(leafletCN)
library(maptools)
library(leaflet.extras)
# 热力图 heatmap
leaflet(res, options = leafletOptions(minZoom = minZoom, maxZoom = maxZoom)) |>
amap() |>
# setView(lng = mean(data$long), lat = mean(data$lat), zoom = zoom) |>
setView(lng = 109, lat = 38, zoom = 4) |>
addHeatmap(
lng = ~long2, lat = ~lat2, intensity = ~uv, max = max(res$uv),
blur = blur, minOpacity = minOpacity, radius = radius
)
quakes$popup_text <- lapply(paste(
"编号:", "<strong>", quakes$stations, "</strong>", "<br>",
"震深:", quakes$depth, "<br>",
"震级:", quakes$mag
), htmltools::HTML)
# 构造调色板
pal <- colorBin("Spectral", bins = pretty(quakes$mag), reverse = TRUE)
leaflet(quakes) |>
addProviderTiles(providers$CartoDB.Positron) |>
addCircles(
lng = ~long, lat = ~lat,
color = ~ pal(mag), label = ~popup_text
) |>
setView(178, -20, 5) |>
addHeatmap(
lng = ~long, lat = ~lat, intensity = ~mag,
blur = 20, max = 0.05, radius = 15
) |>
addLegend("bottomright",
pal = pal, values = ~mag,
title = "地震震级"
) |>
addScaleBar(position = c("bottomleft"))12.28 动画
# https://d.cosx.org/d/422311
library(echarts4r)
data("gapminder", package = "gapminder")
titles <- lapply(unique(gapminder$year), function(x) {
list(
text = "Gapminder",
left = "center"
)
})
years <- lapply(unique(gapminder$year), function(x) {
list(
subtext = x,
left = "center",
top = "center",
z = 0,
subtextStyle = list(
fontSize = 100,
color = "rgb(170, 170, 170, 0.5)",
fontWeight = "bolder"
)
)
})
# 添加一列颜色,各大洲和颜色的对应关系可自定义,调整 levels 或 labels 里面的顺序即可,也可不指定 levels ,调用其它调色板
gapminder <- within(gapminder, {
color <- factor(
continent,
levels = c("Asia", "Africa", "Americas", "Europe", "Oceania"),
labels = RColorBrewer::brewer.pal(n = 5, name = "Spectral")
)
})
gapminder |>
group_by(year) |>
e_charts(x = gdpPercap, timeline = TRUE) |>
e_scatter(
serie = lifeExp, size = pop, bind = country,
symbol_size = 5, name = ""
) |>
e_add("itemStyle", color) |>
e_y_axis(
min = 20, max = 85, nameGap = 30,
name = "Life Exp", nameLocation = "center"
) |>
e_x_axis(
type = "log", min = 100, max = 100000,
nameGap = 30, name = "GDP / Cap", nameLocation = "center"
) |>
e_timeline_serie(title = titles) |>
e_timeline_serie(title = years, index = 2) |>
e_timeline_opts(playInterval = 1000) |>
e_grid(bottom = 100) |>
e_tooltip()12.29 网络图
gephi 探索和可视化网络图 GraphViz
# library(igraph)12.29.1 networkD3
networkD3 D3 非常适合绘制网络图,如网络、树状、桑基图
## source target value
## 1 1 0 1
## 2 2 0 8
## 3 3 0 10
## 4 3 2 6
## 5 4 0 1
## 6 5 0 1
head(MisNodes) # 节点## name group size
## 1 Myriel 1 15
## 2 Napoleon 1 20
## 3 Mlle.Baptistine 1 23
## 4 Mme.Magloire 1 30
## 5 CountessdeLo 1 11
## 6 Geborand 1 9
构造网络图
forceNetwork(
Links = MisLinks, Nodes = MisNodes, Source = "source",
Target = "target", Value = "value", NodeID = "name",
Group = "group", opacity = 0.4
)12.29.2 visNetwork
visNetwork 使用 vis-network.js 库绘制网络关系图 https://datastorm-open.github.io/visNetwork
调用函数 visTree() 可视化分类模型结果
library(rpart)
library(sparkline) # 函数 visTree 需要导入 sparkline 包
res <- rpart(Species~., data=iris)
visTree(res, main = "鸢尾花分类树", width = "100%")节点、边的属性都可以映射数据指标
12.29.3 r2d3
D3 是非常流行的 JavaScript 库,r2d3 提供了 R 接口
更加具体的使用介绍,一个复杂的案例,如何从简单配置过来,以条形图为例, D3 是一个相当强大且成熟的库,提供的案例功能要覆盖 plotly
r2d3 提供了两个样例 JS 库 baranims.js 和 barchart.js
list.files(system.file("examples/", package = "r2d3"))## [1] "baranims.js" "barchart.js"
library(r2d3)
r2d3(
data = c(0.3, 0.6, 0.8, 0.95, 0.40, 0.20),
script = system.file("examples/barchart.js", package = "r2d3")
)图 12.26: D3 图形
r2d3(
data = c(0.3, 0.6, 0.8, 0.95, 0.40, 0.20),
script = system.file("examples/baranims.js", package = "r2d3")
)图 12.27: D3 图形
12.30 运行环境
## R version 4.2.0 (2022-04-22)
## Platform: x86_64-pc-linux-gnu (64-bit)
## Running under: Ubuntu 20.04.5 LTS
##
## Matrix products: default
## BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0
## LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0
##
## locale:
## [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C
## [3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8
## [5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8
## [7] LC_PAPER=en_US.UTF-8 LC_NAME=C
## [9] LC_ADDRESS=C LC_TELEPHONE=C
## [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] sparkline_2.0 rpart_4.1.16 visNetwork_2.1.0 networkD3_0.4
## [5] echarts4r_0.4.3 dplyr_1.0.9 vistime_1.2.1 rasterly_0.2.0
## [9] Rcpp_1.0.8.3 data.table_1.14.2 r2d3_0.2.6 plotly_4.10.0
## [13] ggplot2_3.3.6
##
## loaded via a namespace (and not attached):
## [1] httr_1.4.3 sass_0.4.1
## [3] tidyr_1.2.0 jsonlite_1.8.0
## [5] viridisLite_0.4.0 bslib_0.3.1
## [7] shiny_1.7.1 assertthat_0.2.1
## [9] highr_0.9 yaml_2.3.5
## [11] ggrepel_0.9.1 pillar_1.7.0
## [13] glue_1.6.2 digest_0.6.29
## [15] assertive.types_0.0-3 RColorBrewer_1.1-3
## [17] promises_1.2.0.1 colorspace_2.0-3
## [19] htmltools_0.5.2 httpuv_1.6.5
## [21] pkgconfig_2.0.3 assertive.properties_0.0-5
## [23] bookdown_0.26 sysfonts_0.8.8
## [25] purrr_0.3.4 xtable_1.8-4
## [27] scales_1.2.0 later_1.3.0
## [29] downlit_0.4.0 tibble_3.1.7
## [31] generics_0.1.2 farver_2.1.0
## [33] ellipsis_0.3.2 cachem_1.0.6
## [35] withr_2.5.0 lazyeval_0.2.2
## [37] cli_3.3.0 magrittr_2.0.3
## [39] crayon_1.5.1 mime_0.12
## [41] memoise_2.0.1 evaluate_0.15
## [43] fs_1.5.2 fansi_1.0.3
## [45] MASS_7.3-57 xml2_1.3.3
## [47] tools_4.2.0 lifecycle_1.0.1
## [49] stringr_1.4.0 munsell_0.5.0
## [51] isoband_0.2.5 compiler_4.2.0
## [53] jquerylib_0.1.4 rlang_1.0.2
## [55] grid_4.2.0 rstudioapi_0.13
## [57] htmlwidgets_1.5.4 crosstalk_1.2.0
## [59] assertive.base_0.0-9 igraph_1.3.1
## [61] labeling_0.4.2 rmarkdown_2.14
## [63] gtable_0.3.0 codetools_0.2-18
## [65] DBI_1.1.2 curl_4.3.2
## [67] R6_2.5.1 knitr_1.39
## [69] fastmap_1.1.0 utf8_1.2.2
## [71] stringi_1.7.6 vctrs_0.4.1
## [73] png_0.1-7 tidyselect_1.1.2
## [75] xfun_0.31